home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / cpp_libs / tools / cie.lha / cie / tags.el < prev   
Lisp/Scheme  |  1993-06-21  |  25KB  |  716 lines
  1. ;; Tags facility for Emacs.
  2. ;; Copyright (C) 1985, 1986, 1988 Free Software Foundation, Inc.
  3.  
  4. ;; This file WAS part of some old GNU Emacs.
  5.  
  6. ;; GNU Emacs is distributed in the hope that it will be useful,
  7. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  8. ;; accepts responsibility to anyone for the consequences of using it
  9. ;; or for whether it serves any particular purpose or works at all,
  10. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  11. ;; License for full details.
  12.  
  13. ;; Everyone is granted permission to copy, modify and redistribute
  14. ;; GNU Emacs, but only under the conditions described in the
  15. ;; GNU Emacs General Public License.   A copy of this license is
  16. ;; supposed to have been given to you along with GNU Emacs so you
  17. ;; can know your rights and responsibilities.  It should be in a
  18. ;; file named COPYING.  Among other things, the copyright notice
  19. ;; and this notice must be preserved on all copies.
  20.  
  21. ;; $Id: tags.el,v 1.5 1993/05/13 17:22:55 kennedy Exp $
  22. ;;
  23. ;; NOTE:
  24. ;; 1.    Quick fix inserted for C users.  The problem is that in the tags line
  25. ;;
  26. ;;        typedef char *string^?...
  27. ;;
  28. ;;    `string' won't be an exact match, because the `*' is a word character
  29. ;;    in the TAGS buffer (although not in a C source file).  The quick fix is
  30. ;;    in tag-exact-match-p; look for "HACK 7/19/89".
  31. ;; 2.   Fixed tags-completion-alist problem 1/23/90.
  32.  
  33. ;; INTELLECTION MODS:
  34. ;; 
  35. ;; 1) Prefers the tags named explicitly after C-A's at the end of each line.
  36. ;;    This is true both for find-tag and for the completion-alist.
  37. ;; 2) Support for C++ scoping -- class::name is considered a tag and both
  38. ;;    class::name and name are matches (class::name preferred though).
  39. ;; 3) Support for completion of scoped names as well as unscoped names.
  40. ;;    That is, the alist contains both the fully-scoped name, and each
  41. ;;    subname (c1::c2::mem => c1::c2::mem, c2::mem, and mem in the alist).
  42. ;; 4) Added mechanism to save out the completion alist into TAGS.alist
  43. ;;    which is checked for when loading TAGS to prevent the need to rebuild
  44. ;;    the alist (which can take a while with large systems).  As an added
  45. ;;    advantage, this mechanism removes duplicates from the alist before
  46. ;;    saving it out (making it faster and much smaller).
  47.  
  48.  
  49. (provide 'tags)
  50.  
  51. (defvar tags-prompt-with-initial-input nil
  52.   "*When non-nil, supply default tag as initial input when prompting")
  53.  
  54. ;; Tag table state.
  55.  
  56. (defun initialize-new-tag-table ()
  57.   "Call when the tag table changes."
  58.   (setq tag-table-files nil
  59.     find-tag-state nil
  60.     tag-order nil
  61.     tag-lines-already-matched nil)
  62.   (make-local-variable 'tags-completion-alist) )
  63.  
  64. (defun save-tags-state ()
  65.   "Returns an object that can later be passed to `restore-tags-state'."
  66.   (vector tag-order
  67.       tag-lines-already-matched
  68.       tag-table-files
  69.       find-tag-state
  70.       next-file-list))
  71.  
  72. (defun restore-tags-state (state)
  73.   "Restore from an object created by `save-tags-state'."
  74.   (setq tag-order (aref state 0)
  75.     tag-lines-already-matched (aref state 1)
  76.     tag-table-files (aref state 2)
  77.     find-tag-state (aref state 3)
  78.     next-file-list (aref state 4)))
  79.  
  80. (defvar tag-order nil
  81.   "List of functions to use in partitioning the set of tag matches.")
  82.  
  83. (defvar tag-lines-already-matched nil
  84.   "List of lines within the tag table that are already matched.")
  85.  
  86. (defvar tag-table-files nil
  87.   "List of file names covered by current tags table.
  88. nil means it has not been computed yet; do (tag-table-files) to compute it.")
  89.  
  90. (defvar tags-completion-alist nil
  91.   "Alist of tag names defined in current tags table.")
  92.  
  93. (defvar find-tag-state nil
  94.   "Some of the state of the last find-tag, find-tag-other-window, or
  95. find-tag-regexp.  This is a vector whose 0th element is the last tagname
  96. or regexp used.")
  97.  
  98. (defvar tags-table-file-list nil
  99.   "Alist of tags table file names for \\[select-tags-table].
  100. Each element is a list containing one element, a file name.
  101. Any tags table file you visit is automatically added to this list.
  102. You can also add names yourself.")
  103.  
  104. (defvar next-file-list nil
  105.   "List of files for \\[next-file] to process.")
  106.  
  107.  
  108.  
  109. (defun visit-tags-table (file)
  110.   "Tell tags commands to use tags table file FILE.
  111. FILE should be the name of a file created with the `etags' program.
  112. A directory name is ok too; it means file TAGS in that directory."
  113.   (interactive (list (read-file-name "Visit tags table: (default TAGS) "
  114.                      default-directory
  115.                      (expand-file-name "TAGS" default-directory)
  116.                      t)))
  117.   (setq file (expand-file-name file default-directory))
  118.   (if (file-directory-p file)
  119.       (setq file (expand-file-name "TAGS" file)))
  120.   ;; Add an element to TAGS-TABLE-FILE-LIST.
  121.   (or (assoc file tags-table-file-list)
  122.       (setq tags-table-file-list
  123.         (cons (list file) tags-table-file-list)))
  124.   (setq tags-file-name file)
  125.   (save-excursion
  126.     (visit-tags-table-buffer)))
  127.  
  128.  
  129. (defun visit-tags-table-buffer ()
  130.   "Select the buffer containing the current tags table.
  131. This is a file whose name is in the variable tags-file-name."
  132.   (or tags-file-name
  133.       (call-interactively 'visit-tags-table))
  134.   (let ((new-file nil))
  135.     (set-buffer (or (get-file-buffer tags-file-name)
  136.             (progn
  137.               (initialize-new-tag-table)
  138.               (setq new-file t)
  139.               (find-file-noselect tags-file-name))))
  140.     (or (not new-file)
  141.     (progn
  142.       (initialize-new-tag-table)
  143.       ;; reclaim memory from old alist before creating new.
  144.       (setq tags-completion-alist nil)
  145.       (garbage-collect)
  146.       (setq tags-completion-alist (tags-completion-alist)))))
  147.   (or (verify-visited-file-modtime (get-file-buffer tags-file-name))
  148.       (cond ((yes-or-no-p "Tags file has changed, read new contents? ")
  149.          (revert-buffer t t)
  150.          (initialize-new-tag-table)
  151.          ;; reclaim memory from old alist before creating new.
  152.          (setq tags-completion-alist nil)
  153.          (garbage-collect)
  154.          (setq tags-completion-alist (tags-completion-alist)))))
  155.   (or (eq (char-after 1) ?\^L)
  156.       (error "File %s not a valid tag table" tags-file-name)))
  157.  
  158.  
  159. (defun file-of-tag ()
  160.   "Return the file name of the file whose tags point is within.
  161. Assumes the tag table is the current buffer.
  162. File name returned is relative to tag table file's directory."
  163.   (save-excursion
  164.     (search-backward "\f\n")
  165.     (forward-char 2)
  166.     (buffer-substring (point)
  167.               (progn (skip-chars-forward "^,") (point)))))
  168.  
  169. (defun tag-table-files ()
  170.   "Return a list of files in the current tag table.
  171. File names returned are absolute."
  172.   (or tag-table-files
  173.       (save-excursion
  174.     (visit-tags-table-buffer)
  175.     (let (files)
  176.       (goto-char (point-min))
  177.       (while (search-forward "\f\n" nil t)
  178.         (setq files (cons (expand-file-name
  179.                 (buffer-substring
  180.                   (point)
  181.                   (progn (skip-chars-forward "^,\n") (point)))
  182.                 (file-name-directory tags-file-name))
  183.                   files)))
  184.       (setq tag-table-files (nreverse files))))))
  185.  
  186. (defun tags-completion-alist ()
  187.   "Return an alist of tags in the current buffer, which is a tag table."
  188.   ; BMK: read alist if a .alist file exists and is newer
  189.   (let ((alist nil)
  190.     (alist-file (concat buffer-file-name ".alist")))
  191.     (if (and (file-readable-p alist-file)
  192.          (file-newer-than-file-p alist-file buffer-file-name))
  193.     (load-file alist-file)
  194.       (let ((gc-cons-threshold 1000000)
  195.         (next nil))
  196.     (message "Making tags completion alist...")
  197.     (save-excursion
  198.       (goto-char (point-min))
  199.       (while (search-forward "\177" nil t)
  200.         (if (save-excursion
  201.           (skip-chars-forward "^\001\n")
  202.           (setq next (1+ (point)))
  203.           (= (following-char) ?\001))
  204.         ;; If there are ^A's, get tags after them.
  205.         ;; BMK: for each, get each subscoped tag down to id
  206.         (progn
  207.           (goto-char next)    ;; after the first ^A
  208.           (while (= (preceding-char) ?\001)
  209.             (while (not (looking-at "[\001\n]"))
  210.               (skip-chars-forward ":")
  211.               (setq alist 
  212.                 (cons (cons (buffer-substring (point)
  213.                               (save-excursion 
  214.                                 (skip-chars-forward "^\001\n")
  215.                                 (point)))
  216.                     nil)
  217.                   alist))
  218.               (skip-chars-forward "^:\001\n"))
  219.             (forward-char 1)))
  220.           ;; If no ^A's, get tags from before the ^?.
  221.           (skip-chars-backward "^-A-Za-z0-9_$:~\n")
  222.           (or (bolp)
  223.           (setq alist
  224.             (cons (cons (buffer-substring
  225.                      (point)
  226.                      (progn
  227.                        (skip-chars-backward "-A-Za-z0-9_$:~")
  228.                        (point)))
  229.                     nil)
  230.                   alist)))
  231.           (goto-char next)        ; next line
  232.           )))
  233.     (message "Making tags completion alist...done")))
  234.     alist) )
  235.  
  236. (defun tags-alist-less-p (a b)
  237.   (string< (car a) (car b)))
  238.  
  239. (defun save-tags-completion-alist ()
  240.   "Save out a .alist file for this tags table."
  241.   (interactive)
  242.   (save-excursion
  243.     (visit-tags-table-buffer)
  244.     ;; sort list then eliminate duplicates
  245.     (message "Removing duplicates from tags completion alist...")
  246.     (setq tags-completion-alist
  247.       (sort tags-completion-alist 'tags-alist-less-p))
  248.     (let ((l tags-completion-alist))
  249.       (while (and l (cdr l))
  250.     ;; compare current element to next
  251.     (if (not (string= (car (car l)) (car (car (cdr l)))))
  252.         ;; no match, proceed to next element
  253.         (setq l (cdr l))    
  254.       ;; match, drop next element.
  255.       (setcdr l (cdr (cdr l))))))
  256.     (garbage-collect)
  257.     ;; generate lisp form that will recreate the completion alist
  258.     (let* ((alist-file (concat buffer-file-name ".alist"))
  259.        (alist-buffer (get-buffer-create "*TAGS-alist*")) )
  260.       (prin1 (list 'setq 'alist (list 'quote tags-completion-alist))
  261.          alist-buffer)
  262.       (terpri alist-buffer)
  263.       (set-buffer alist-buffer)
  264.       (write-file alist-file)
  265.       (kill-buffer alist-buffer) ) )
  266.   )
  267.  
  268.  
  269. ;; BMK: give completing-read an initial input
  270. (defun prompt-for-tag (prompt)
  271.   "Prompt for a tag to find.  Default is determined by find-tag-default."
  272.   (let* ((default (find-tag-default))
  273.      (alist (save-excursion (visit-tags-table-buffer)
  274.                 tags-completion-alist))
  275.      (read-prompt (if (or (not default) tags-prompt-with-initial-input)
  276.               prompt
  277.             (format "%s(default %s) " prompt default)))
  278.      (initial-input (if tags-prompt-with-initial-input default nil))
  279.      (minibuffer-yank-string default)
  280.      spec)
  281.     (setq spec (completing-read read-prompt
  282.                 ;; completing-read craps out if given a nil table
  283.                 (or alist '(("")))
  284.                 nil
  285.                 nil
  286.                 initial-input))
  287.     (if (equal spec "")
  288.     (if (or tags-prompt-with-initial-input (null default))
  289.         (error "No tag specified.")
  290.       default)
  291.       spec)))
  292.  
  293.  
  294. ;; Return a default tag to search for, based on the text at point, or nil.
  295. ;; BMK: Grab fully-scoped C++ tags as the default.  
  296. ;;      This is highly preferable.  The old function is below.
  297. (defun find-tag-default ()
  298.   (save-excursion
  299.     ; Find end of default tag
  300.     (if (looking-at "\\sw\\|\\s_")
  301.     (while (looking-at "\\sw\\|\\s_")
  302.       (forward-char 1))
  303.       (progn (while (and (not (bobp)) (not (looking-at "\\sw\\|\\s_")))
  304.            (forward-char -1))
  305.          (if (and (not (eobp)) (looking-at "\\sw\\|\\s_"))
  306.          (forward-char 1) )))
  307.     (if (bobp) ; no tag found
  308.     nil
  309.       (let ((end-point (point)))
  310.     (forward-char -1)
  311.     (while (and (not (bobp)) (looking-at "\\sw\\|\\s_\\|:"))
  312.       (forward-char -1))
  313.     (while (not (looking-at "\\sw\\|\\s_"))
  314.         (forward-char 1))
  315.     (if (looking-at "[A-Z]\\|[a-z]\\|:\\s_")
  316.         (buffer-substring (point) end-point)
  317.       nil)))))
  318.  
  319. ;;(defun find-tag-default ()
  320. ;;  (save-excursion
  321. ;;    (while (looking-at "\\sw\\|\\s_")
  322. ;;      (forward-char 1))
  323. ;;    (if (re-search-backward "\\sw\\|\\s_" nil t)
  324. ;;    (progn (forward-char 1)
  325. ;;           (buffer-substring (point)
  326. ;;                 (progn (forward-sexp -1)
  327. ;;                    (while (looking-at "\\s'")
  328. ;;                      (forward-char 1))
  329. ;;                    (point))))
  330. ;;      nil)))
  331.  
  332.  
  333. (defun find-tag (tagname &optional next-p other-window regexp-p)
  334.   "Find tag (in current tag table) whose name contains TAGNAME;
  335. more exact matches are found first.
  336. Select the buffer containing the tag's definition and move point there.
  337. The default for TAGNAME is the expression in the buffer after or around point.
  338.  
  339. If second arg NEXT-P is non-nil (interactively, with prefix arg), search
  340. for another tag that matches the last tagname or regexp used.
  341.  
  342. If third arg OTHER-WINDOW is non-nil, select the buffer in another window.
  343.  
  344. If fourth arg REGEXP-P is non-nil, treat TAGNAME as a regexp.
  345.  
  346. See documentation of variable `tags-file-name'."
  347.   (interactive (if current-prefix-arg
  348.            '(nil t)
  349.            (list (prompt-for-tag "Find tag: "))))
  350.   (cond
  351.    (next-p (find-tag-in-order nil nil nil nil nil other-window))
  352.    (regexp-p (find-tag-in-order tagname
  353.                 're-search-forward
  354.                 '(tag-re-match-p)
  355.                 t
  356.                 "matching"
  357.                 other-window))
  358.    (t
  359.     (find-tag-in-order
  360.      tagname
  361.      'search-forward
  362.      '(tag-exact-match-rhs-p 
  363.        tag-member-match-rhs-p 
  364.        tag-exact-match-p 
  365.        tag-word-match-p 
  366.        tag-any-match-p)
  367.      nil
  368.      "containing"
  369.      other-window))))
  370.  
  371. (defun find-tag-other-window (tagname &optional next-p)
  372.   "Find tag (in current tag table) whose name contains TAGNAME;
  373. more exact matches are found first.
  374. Select the buffer containing the tag's definition
  375. in another window, and move point there.
  376. The default for TAGNAME is the expression in the buffer around or before point.
  377.  
  378. If second arg NEXT-P is non-nil (interactively, with prefix arg), search
  379. for another tag that matches the last tagname used.
  380.  
  381. See documentation of variable `tags-file-name'."
  382.   (interactive (if current-prefix-arg
  383.            '(nil t)
  384.            (list (prompt-for-tag "Find tag other window: "))))
  385.   (find-tag tagname next-p t))
  386.  
  387. (defun find-tag-regexp (regexp &optional next-p other-window)
  388.   "Find tag (in current tag table) whose name matches REGEXP.
  389. Select the buffer containing the tag's definition and move point there.
  390.  
  391. If second arg NEXT-P is non-nil (interactively, with prefix arg), search
  392. for another tag that matches the last tagname used.
  393.  
  394. If third arg OTHER-WINDOW is non-nil, select the buffer in another window.
  395.  
  396. See documentation of variable `tags-file-name'."
  397.   (interactive (if current-prefix-arg
  398.            '(nil t)
  399.          (list (read-string "Find tag regexp: "))))
  400.   (find-tag regexp next-p other-window t))
  401.  
  402. (defun find-tag-in-order
  403.   (pattern search-forward-func order next-line-after-failure-p matching other-window)
  404.   "Internal tag finding function.  PATTERN is a string to pass to
  405. second arg SEARCH-FORWARD-FUNC, and to any member of the function list
  406. ORDER (third arg).  If ORDER is nil, use saved state to continue a
  407. previous search.
  408.  
  409. Fourth arg MATCHING is a string, an English '-ing' word, to be used in
  410. an error message.
  411.  
  412. Fifth arg NEXT-LINE-AFTER-FAILURE-P is non-nil if after a failed match,
  413. point should be moved to the next line.
  414.  
  415. If sixth arg OTHER-WINDOW is non-nil, select the buffer in another window.
  416.  
  417. Algorithm is as follows.  For each qualifier-func in ORDER, go to
  418. beginning of tags file, and perform inner loop: for each naive match for
  419. PATTERN found using SEARCH-FORWARD-FUNC, qualify the naive match using
  420. qualifier-func.  If it qualifies, go to the specified line in the
  421. specified source file and return.  Qualified matches are remembered to
  422. avoid repetition.  State is saved so that the loop can be continued."
  423.   (let (file linebeg startpos)
  424.     (save-excursion
  425.       (visit-tags-table-buffer)
  426.       (if order
  427.       (progn
  428.         ;; Save state.
  429.         (setq find-tag-state (vector pattern search-forward-func matching)
  430.           tag-order order
  431.           tag-lines-already-matched nil)
  432.         ;; Start at beginning of tags file.
  433.         (goto-char (point-min)))
  434.     (progn
  435.       ;; Restore state.
  436.       (setq pattern (aref find-tag-state 0)
  437.         search-forward-func (aref find-tag-state 1)
  438.         matching (aref find-tag-state 2))))
  439.  
  440.       ;; Get a qualified match.
  441.       (catch 'qualified-match-found
  442.     (while (car tag-order)
  443.       (while (funcall search-forward-func pattern nil t)
  444.         ;; Naive match found.
  445.         (if (and
  446.          ;; Qualify the match.
  447.          (funcall (car tag-order) pattern)
  448.          ;; Make sure it is not a previous qualified match.
  449.          ;; Use of `memq' depends on numbers being eq.
  450.          (not (memq (save-excursion (beginning-of-line) (point))
  451.                 tag-lines-already-matched)))
  452.         (throw 'qualified-match-found nil))
  453.         (if next-line-after-failure-p (forward-line 1)))
  454.       (setq tag-order (cdr tag-order))
  455.       (goto-char (point-min)))
  456.     (error "No %stags %s %s" (if order "" "more ") matching pattern))
  457.  
  458.       ;; Found a tag; extract location info.
  459.       (beginning-of-line)
  460.       (setq tag-lines-already-matched (cons (point) tag-lines-already-matched))
  461.       (search-forward "\177")
  462.       (setq file (expand-file-name (file-of-tag)
  463.                    (file-name-directory tags-file-name)))
  464.       (setq linebeg
  465.         (buffer-substring (1- (point))
  466.                   (save-excursion (beginning-of-line) (point))))
  467.       (search-forward ",")
  468.       (setq startpos (string-to-int (buffer-substring
  469.                       (point)
  470.                       (progn (skip-chars-forward "0-9")
  471.                          (point)))))
  472.       ;; Leave point on next line of tags file.
  473.       (forward-line 1))
  474.  
  475.     ;; Find the right line in the specified file.
  476.     (if other-window
  477.     (find-file-other-window file)
  478.       (find-file file))
  479.     (widen)
  480.     (push-mark)
  481.  
  482.     (let ((offset 16)    ;; this constant is 1/2 the initial search window
  483.       found
  484.       (pat (concat "^" (regexp-quote linebeg))))
  485.       (or startpos (setq startpos (point-min)))
  486.       (while (and (not found)
  487.           (progn
  488.            (goto-char (- startpos offset))
  489.            (not (bobp))))
  490.     (setq found
  491.           (re-search-forward pat (+ startpos offset (length pat)) t))
  492.     (setq offset (* 4 offset)))    ;; expand search window
  493.       (or found
  494.       (re-search-forward pat nil t)
  495.       (error "\"%s\" not found in %s; time to rerun etags" pat file)))
  496.     (beginning-of-line))
  497.   (setq tags-loop-form '(find-tag-in-order nil nil nil nil nil nil))
  498.   ;; Return t in case used as the tags-loop-form.
  499.   t)
  500.  
  501. ;;; Match qualifier functions for tagnames.
  502.  
  503. (defun tag-exact-match-rhs-p (tag)
  504.   "Did we find an exact, case sensitive match for TAG following a Control-A?
  505. Assume point is in a tags file, immediately after an occurence of TAG."
  506.   (let ((tag-length (length tag)))
  507.     (and (looking-at "[\001\n]")
  508.      (save-excursion
  509.        (backward-char tag-length)
  510.        (and (= (preceding-char) ?\001)
  511.         (let ((case-fold-search nil))
  512.           (looking-at tag)))))))
  513.  
  514. (defun tag-member-match-rhs-p (tag)
  515.   "Did we find an exact, case sensitive match for TAG following a colon following a Control-A?
  516. Assume point is in a tags file, immediately after an occurence of TAG."
  517.   (let ((tag-length (length tag)))
  518.     (and (looking-at "[\001\n]")
  519.      (save-excursion
  520.        (backward-char tag-length)
  521.        (and (or (= (preceding-char) ?\001) (= (preceding-char) ?:))
  522.         (let ((case-fold-search nil))
  523.           (looking-at tag)))))))
  524.  
  525.  
  526. (defun tag-exact-match-p (tag)
  527.   "Did we find an exact match for TAG?  Assume point is in a tags file,
  528. immediately after an occurence of TAG."
  529.   (let ((tag-length (length tag)))
  530.     (or (and (looking-at "[ \t();,]?\177")
  531.          (save-excursion (backward-char tag-length)
  532.                  (or (bolp)
  533.                  (let ((c (preceding-char)))
  534.                    (or (= c ? ) (= c ?\t)
  535.                        (= c ?*)    ;; HACK 7/19/89
  536.                        )))))
  537.     (and (looking-at "[\001\n]")
  538.          (save-excursion (backward-char tag-length)
  539.                  (= (preceding-char) ?\001))))))
  540.  
  541. (defun tag-word-match-p (tag)
  542.   "Did we find a word match for TAG?  Assume point is in a tags file,
  543. immediately after an occurence of TAG."
  544.   (let ((tag-length (length tag)))
  545.     (or (and (looking-at "\\b.*\177")
  546.          (save-excursion (backward-char tag-length)
  547.                  (looking-at "\\b")))
  548.     (and (looking-at "\\b.*[\001\n]")
  549.          (save-excursion (backward-char tag-length)
  550.                  (and
  551.                   (looking-at "\\b")
  552.                   (progn
  553.                 (skip-chars-backward "^\001\n")
  554.                 (= (preceding-char) ?\001))))))))
  555.  
  556. (defun tag-any-match-p (tag)
  557.   "Did we find any match for TAG?  Assume point is in a tags file,
  558. immediately after an occurence of TAG."
  559.   (or (looking-at ".*\177")
  560.       (save-excursion
  561.     (backward-char (length tag))
  562.     (skip-chars-backward "^\001\n")
  563.     (= (preceding-char) ?\001))))
  564.  
  565. ;;; Match qualifier function for regexps.
  566.  
  567. (defun tag-re-match-p (re)
  568.   "Is point (in a tags file) on a line with a match for RE?"
  569.   (save-excursion
  570.     (beginning-of-line)
  571.     (catch 'done
  572.       (let* ((bol (point))
  573.          (eol (save-excursion (end-of-line) (point)))
  574.          (del (save-excursion (if (search-forward "\177" eol t)
  575.                       (point)
  576.                     (throw 'done nil)))))
  577.      (if (search-forward "\001" eol t)
  578.          ;; There are ^A's: try to match in each tag after a ^A
  579.          (let ((bot (point))
  580.            eot)
  581.            (while (< bot eol)
  582.          (save-excursion
  583.            (setq eot (if (search-forward "\001" eol t)
  584.                     (1- (point))
  585.                   eol))
  586.            (if (re-search-forward re eot t)
  587.                (throw 'done t))
  588.            (setq bot (1+ eot))
  589.            (goto-char bot))))
  590.        ;; No ^A: try to match the line before the ^?
  591.        (goto-char bol)
  592.        (re-search-forward re (1- del) t))))))
  593.  
  594. (defun next-file (&optional initialize)
  595.   "Select next file among files in current tag table.
  596. Non-nil argument (prefix arg, if interactive)
  597. initializes to the beginning of the list of files in the tag table."
  598.   (interactive "P")
  599.   (if initialize
  600.       (setq next-file-list (tag-table-files)))
  601.   (or next-file-list
  602.       (error "All files processed."))
  603.   (find-file (car next-file-list))
  604.   (setq next-file-list (cdr next-file-list)))
  605.  
  606. (defvar tags-loop-form nil
  607.   "Form for tags-loop-continue to eval to process one file.
  608. If it returns nil, it is through with one file; move on to next.")
  609.  
  610. (defun tags-loop-continue (&optional first-time)
  611.   "Continue last \\[find-tag], \\[tags-search], or
  612. \\[tags-query-replace] command.  Used noninteractively with non-nil
  613. argument to begin such a command.  See variable `tags-loop-form'."
  614.   (interactive)
  615.   (if first-time
  616.       (progn (next-file t)
  617.          (goto-char (point-min))))
  618.   (while (not (eval tags-loop-form))
  619.     (next-file)
  620.     (message "Scanning file %s..." buffer-file-name)
  621.     (goto-char (point-min))))
  622.  
  623. (defun tags-search (regexp)
  624.   "Search through all files listed in tag table for match for REGEXP.
  625. Stops when a match is found.
  626. To continue searching for next match, use command \\[tags-loop-continue].
  627.  
  628. See documentation of variable tags-file-name."
  629.   (interactive "sTags search (regexp): ")
  630.   (if (and (equal regexp "")
  631.        (eq (car tags-loop-form) 're-search-forward))
  632.       (tags-loop-continue nil)
  633.     (setq tags-loop-form
  634.       (list 're-search-forward regexp nil t))
  635.     (tags-loop-continue t)))
  636.  
  637. (defun tags-query-replace (from to)
  638.   "Query-replace-regexp FROM with TO through all files listed in tag table.
  639. If you exit (C-G or ESC), you can resume the query-replace
  640. with the command \\[tags-loop-continue].
  641.  
  642. See documentation of variable tags-file-name."
  643.   (interactive "sTags query replace (regexp): \nsTags query replace %s by: ")
  644.   (setq tags-loop-form
  645.     (list 'and (list 'save-excursion
  646.              (list 're-search-forward from nil t))
  647.           (list 'not (list 'perform-replace from to t t nil))))
  648.   (tags-loop-continue t))
  649.  
  650. (defun list-tags (string)
  651.   "Display list of tags in file FILE.
  652. FILE should not contain a directory spec
  653. unless it has one in the tag table."
  654.   (interactive "sList tags (in file): ")
  655.   (with-output-to-temp-buffer "*Tags List*"
  656.     (princ "Tags in file ")
  657.     (princ string)
  658.     (terpri)
  659.     (save-excursion
  660.      (visit-tags-table-buffer)
  661.      (goto-char 1)
  662.      (search-forward (concat "\f\n" string ","))
  663.      (forward-line 1)
  664.      (while (not (looking-at "\f"))
  665.        (princ (buffer-substring (point)
  666.                 (progn (skip-chars-forward "^\177")
  667.                        (point))))
  668.        (terpri)
  669.        (forward-line 1)))))
  670.  
  671. (defun tags-apropos (string)
  672.   "Display list of all tags in tag table REGEXP matches."
  673.   (interactive "sTag apropos (regexp): ")
  674.   (with-output-to-temp-buffer "*Tags List*"
  675.     (princ "Tags matching regexp ")
  676.     (prin1 string)
  677.     (terpri)
  678.     (save-excursion
  679.      (visit-tags-table-buffer)
  680.      (goto-char 1)
  681.      (while (re-search-forward string nil t)
  682.        (beginning-of-line)
  683.        (princ (buffer-substring (point)
  684.                 (progn (skip-chars-forward "^\177")
  685.                        (point))))
  686.        (terpri)
  687.        (forward-line 1)))))
  688.  
  689. (defun select-tags-table ()
  690.   "Select a tags table file from a menu of those you have already used.
  691. The list of tags tables to select from is stored in `tags-table-file-list';
  692. see the doc of that variable if you want to add names to the list."
  693.   (interactive)
  694.   (switch-to-buffer "*Tags Table List*")
  695.   (erase-buffer)
  696.   (let ((list tags-table-file-list))
  697.     (while list
  698.       (insert (car (car list)) "\n")
  699.       (setq list (cdr list))))
  700.   (goto-char 1)
  701.   (insert "Type `t' to select a tag table:\n\n")
  702.   (set-buffer-modified-p nil)
  703.   (let ((map (make-sparse-keymap)))
  704.     (define-key map "t" 'select-tags-table-select)
  705.     (use-local-map map)))
  706.   
  707. (defun select-tags-table-select ()
  708.   "Select the tag table named on this line."
  709.   (interactive)
  710.   (let ((name (buffer-substring (point)
  711.                 (save-excursion (end-of-line) (point)))))
  712.     (visit-tags-table name)
  713.     (message "Tag table now %s" name)))
  714.  
  715.  
  716.